home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / w3 / w3-beta.el < prev    next >
Encoding:
Text File  |  1995-08-18  |  12.8 KB  |  387 lines
  1. ;;; w3-beta.el,v --- Misc functions for emacs-w3's new display engine
  2. ;; Author: wmperry
  3. ;; Created: 1995/08/12 00:54:10
  4. ;; Version: 1.42
  5. ;; Keywords: help, hypermedia, comm
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
  9. ;;;
  10. ;;; This file is part of GNU Emacs.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. (defun w3-parse-header-link-items ()
  28.   ;; Parse `url-current-mime-headers' and look for any <link> items
  29.   (let ((items url-current-mime-headers)
  30.     (node nil)
  31.     (url nil)
  32.     (type nil)
  33.     (args nil)
  34.     (title nil)
  35.     (label nil))
  36.     (while items
  37.       (setq node (car items)
  38.         items (cdr items))
  39.       (if (string= (car node) "link")
  40.       (progn
  41.         (setq args (mm-parse-args (cdr node))
  42.           type (if (assoc "rel" args) "rel" "rev")
  43.           label (cdr-safe (assoc type args))
  44.           title (cdr-safe (assoc "title" args))
  45.           url (car-safe (rassoc nil args)))
  46.         (if (string-match "^<.*>$" url)
  47.         (setq url (substring url 1 -1)))
  48.         (and url label type
  49.          (w3-handle-link (list (cons "href" url)
  50.                        (cons type label)
  51.                        (cons "title" title)))))))))
  52.      
  53. (defun w3-refresh-buffer (&rest args)
  54.   "Redraw the current buffer - this does not refetch or reparse the current
  55. document, but uses the stored parse data."
  56.   (interactive)
  57.   (let ((buffer-read-only nil))
  58.     (if (get-buffer url-working-buffer)
  59.     (kill-buffer url-working-buffer))
  60.     (erase-buffer)
  61.     (rename-buffer url-working-buffer)
  62.     (setq w3-delayed-images nil
  63.       w3-current-links nil
  64.       w3-delayed-movies nil)
  65.     (w3-parse-header-link-items)
  66.     (w3-draw-html w3-current-parse)
  67.     (w3-show-buffer)))
  68.  
  69. (defun w3-prepare-buffer (&rest args)
  70.   ;; The text/html viewer - does all the drawing and displaying of the buffer
  71.   ;; that is necessary to go from raw HTML to a good presentation.
  72.   (let* ((source (buffer-string))
  73.      (parse (w3-preparse-buffer (current-buffer)))
  74.      (buff (car parse)))
  75.     (set-buffer-modified-p nil)
  76.     (kill-buffer (current-buffer))
  77.     (set-buffer buff)
  78.     (setq w3-current-source source
  79.       w3-current-parse (cdr parse))
  80.     (w3-parse-header-link-items)
  81.     (save-excursion
  82.       (goto-char (point-max))
  83.       (w3-handle-paragraph)
  84.       (w3-mode)
  85.       (w3-handle-annotations)
  86.       (w3-handle-headers)
  87.       (if (boundp 'MULE) (w3-mule-attribute-zones w3-zones-list))
  88.       (set-buffer-modified-p nil)
  89.       (setq buffer-read-only t))
  90.     (switch-to-buffer (current-buffer))
  91.     (let ((window nil)
  92.       (pop-up-windows nil))
  93.       (display-buffer (current-buffer))
  94.       (if (or w3-running-FSF19 w3-running-xemacs)
  95.       (setq window (get-buffer-window (current-buffer) t))
  96.     (setq window (get-buffer-window (current-buffer))))
  97.       (select-window window)
  98.       (if (and (fboundp 'select-frame)
  99.            (fboundp 'window-frame))
  100.       (select-frame (window-frame window))))
  101.     (goto-char (point-min))
  102.     (w3-show-buffer)
  103.     ;; from MULE contributors
  104.     (and w3-auto-image-alt (w3-show-invisible-href))
  105.     (goto-char (point-min))
  106.     (if url-keep-history
  107.     (let ((url (url-view-url t)))
  108.       (if (and (not (assoc url url-history-list)))
  109.           (setq url-history-list
  110.             (cons (cons url (buffer-name)) url-history-list)))
  111.       (if (fboundp 'w3-shuffle-history-menu)
  112.           (w3-shuffle-history-menu))))))
  113.  
  114. ;;; from MULE contributors
  115. (defun w3-show-graphics ()
  116.   "Displaying inlined image indicator by text."
  117.   (interactive)
  118.   (let ((w3-auto-image-alt (or w3-auto-image-alt t)))
  119.     (w3-refresh-buffer))
  120.   (goto-char (point-min)))
  121.  
  122. (defun w3-handle-headers ()
  123.   ;; Insert any headers the user wants to see into the current buffer.
  124.   (let ((show w3-show-headers)
  125.     (cur nil)
  126.     (hdrs nil)
  127.     (tag 'ol)
  128.     (header nil)
  129.     (w3-last-fill-pos (point-max))
  130.     (val nil)
  131.     (first t))
  132.     (goto-char (point-max))
  133.     (if (eq show t) (setq show '(".*")))
  134.     (while show
  135.       (setq cur (car show)
  136.         show (cdr show)
  137.         hdrs url-current-mime-headers)
  138.       (while hdrs
  139.     (setq header (car (car hdrs))
  140.           val (cdr (car hdrs))
  141.           hdrs (cdr hdrs))
  142.     (if (numberp val) (setq val (int-to-string val)))
  143.     (if (and (/= 0 (length header))
  144.          (string-match cur header))
  145.         (progn
  146.           (if first
  147.           (progn
  148.             (w3-handle-hr)
  149.             (w3-handle-list-opening '(("value" . 1)))
  150.             (setq tag 'li
  151.               first nil)))
  152.           (w3-handle-list-item)
  153.           (w3-handle-text (concat (capitalize header)
  154.                       ": " val))))))
  155.     (if (not first)            ; We showed some headers
  156.     (setq tag '/ol
  157.           tag (w3-handle-list-ending)))))
  158.  
  159. (defun w3-handle-annotations ()
  160.   ;; Insert personal annotations into the current buffer
  161.   (let ((annos (w3-fetch-personal-annotations))
  162.     (tag nil))
  163.     (if (not annos)
  164.     nil                ; No annotations
  165.       (goto-char (cond
  166.           ((eq w3-annotation-position 'bottom) (point-max))
  167.           ((eq w3-annotation-position 'top) (point-min))
  168.           (t (message "Bad value for w3-annotation-position")
  169.              (point-max))))
  170.       (w3-handle-hr '(("align" . "center") ("width" . "50%")))
  171.       (setq tag 'h3)
  172.       (w3-handle-header '(("align" . "center")))
  173.       (setq tag 'ol)
  174.       (w3-handle-list-opening '(("value" . 1)))
  175.       (while annos
  176.     (put 'w3-state 'href (car (car annos)))
  177.     (w3-handle-list-item)
  178.     (w3-handle-text (cdr (car annos)))
  179.     (put 'w3-state 'href nil)
  180.     (setq annos (cdr annos)))
  181.       (w3-handle-list-ending)
  182.       (w3-handle-hr '(("align" . "center") ("width" . "50%"))))))
  183.  
  184. (defun w3-fetch-personal-annotations ()
  185.   ;; Grab any personal annotations for the current url
  186.   (let ((url  (url-view-url t))
  187.     (anno w3-personal-annotations)
  188.     (annolist nil))
  189.     (if (assoc url anno)
  190.     (while anno
  191.       (if (equal (car (car anno)) url)
  192.           (setq annolist
  193.             (cons
  194.              (cons
  195.               (format "file:%s%s/PAN-%s.html"
  196.                   (if (= ?/ (string-to-char
  197.                      w3-personal-annotation-directory)) ""
  198.                 "/")
  199.                   w3-personal-annotation-directory
  200.                   (car (car (cdr (car anno)))))
  201.               (car (cdr (car (cdr (car anno))))))
  202.              annolist)))
  203.       (setq anno (cdr anno))))
  204.     annolist))
  205.  
  206. (defvar w3-netscape-FAT-file "index"
  207.   "*Filename in a netscape cache directory.")
  208.  
  209. (defvar w3-netscape-FAT-tag
  210.   "MCOM-Cache-file-allocation-table-format-1"
  211.   "*The line at the beginning of a netscape cache file.")
  212.  
  213. (defmacro w3-skip-word ()
  214.   (skip-chars-forward "^ \t\n\r")
  215.   (skip-chars-forward " \t"))
  216.  
  217. (defun w3-read-netscape-config (&optional fname)
  218.   "Read in a netscape-style configuration file."
  219.   (interactive "fNetscape configuration file: ")
  220.   (if (not (and (file-exists-p fname)
  221.         (file-readable-p fname)))
  222.       (error "Could not read %s" fname))
  223.   (let ((results nil)
  224.     (tag nil)
  225.     (val nil)
  226.     (var nil)
  227.     (save-pos nil))
  228.     (save-excursion
  229.       (set-buffer (get-buffer-create " *w3-tmp*"))
  230.       (erase-buffer)
  231.       (mm-insert-file-contents fname)
  232.       (goto-char (point-min))
  233.       (skip-chars-forward "^ \t\r\n")    ; Skip tag line
  234.       (skip-chars-forward " \t\r\n")    ; Skip blank line(s)
  235.       (while (not (eobp))
  236.     (setq save-pos (point))
  237.     (skip-chars-forward "^:")
  238.     (upcase-region save-pos (point))
  239.     (setq tag (buffer-substring save-pos (point)))
  240.     (skip-chars-forward ":\t ")
  241.     (setq save-pos (point))
  242.     (skip-chars-forward "^\r\n")
  243.     (setq val (if (= save-pos (point))
  244.               nil
  245.             (buffer-substring save-pos (point))))
  246.     (cond
  247.      ((null val) nil)
  248.      ((string-match "^[0-9]+$" val)
  249.       (setq val (string-to-int val)))
  250.      ((string= "false" (downcase val))
  251.       (setq val nil))
  252.      ((string= "true" (downcase val))
  253.       (setq val t))
  254.      (t nil))
  255.     (skip-chars-forward " \t\n\r")
  256.     (setq results (cons (cons tag val) results))))
  257.     (while results
  258.       (setq tag (car (car results))
  259.         val (cdr (car results))
  260.         var (cdr-safe (assoc tag w3-netscape-variable-mappings))
  261.         results (cdr results))
  262.       (cond
  263.        ((eq var 'w3-delay-image-loads) (set var (not val)))
  264.        (var (set var val))
  265.        (t nil)))))
  266.       
  267. (defun w3-import-netscape-cache (dir)
  268.   "Read in a Netscape-file cache directory and convert it to the Emacs-w3
  269. format."
  270.   (interactive "DNetscape cache directory: ")
  271.   (let ((fname (expand-file-name w3-netscape-FAT-file dir))
  272.     (netscape-name nil)        ; Netscape cache name
  273.     (url nil)            ; Original URL
  274.     (type nil)            ; Content-type of URL
  275.     (length nil)            ; Content-length of URL
  276.     (save-pos nil)            ; Temporary point storage
  277.     (w3-name nil)            ; Emacs-w3 cached name
  278.     (w3-hdrs nil)            ; Header file
  279.     )
  280.     (if (not (and (file-exists-p fname) (file-readable-p fname)))
  281.     (error "%s is not readable..." w3-netscape-FAT-file))
  282.     (set-buffer (get-buffer-create " *w3-tmp*"))
  283.     (erase-buffer)
  284.     (mm-insert-file-contents fname)
  285.     (goto-char (point-min))
  286.     (if (not (looking-at (concat "^" w3-netscape-FAT-tag "\r*$")))
  287.     (error "%s is not a netscape FAT table..." w3-netscape-FAT-file))
  288.     (forward-line 1)            ; Skip tag line
  289.     (while (not (eobp))
  290.       (w3-skip-word)  (w3-skip-word) (w3-skip-word)
  291.       (setq save-pos (point))
  292.       (w3-skip-word)
  293.       (setq netscape-name (expand-file-name
  294.                (w3-fix-spaces (buffer-substring save-pos (point)))
  295.                dir)
  296.         save-pos (point))
  297.       (w3-skip-word)
  298.       (setq url (w3-fix-spaces (buffer-substring save-pos (point)))
  299.         save-pos (point))
  300.       (w3-skip-word)
  301.       (setq type (w3-fix-spaces (buffer-substring save-pos (point)))
  302.         save-pos (point))
  303.       (w3-skip-word)
  304.       (setq length (w3-fix-spaces (buffer-substring save-pos (point))))
  305.       (skip-chars-forward " \t\r\n")
  306.       (setq w3-name (url-create-cached-filename url)
  307.         w3-hdrs (url-generic-parse-url url)
  308.         w3-hdrs (format "(setq url-current-content-length \"%s\"
  309.       url-current-mime-type \"%s\"
  310.       url-current-type \"%s\"
  311.       url-current-user \"%s\"
  312.       url-current-server \"%s\"
  313.       url-current-port \"%s\"
  314.       url-current-file \"%s\"
  315.       url-current-mime-headers '((\"content-type\" . \"%s\")
  316.                  (\"content-length\" . \"%s\")))"
  317.                 length type
  318.                 (url-type w3-hdrs)
  319.                 (url-user w3-hdrs)
  320.                 (url-host w3-hdrs)
  321.                 (url-port w3-hdrs)
  322.                 (url-filename w3-hdrs)
  323.                 type length))
  324.       (condition-case ()
  325.       (make-directory (url-basepath w3-name) t)
  326.     (error nil))
  327.       (write-region w3-hdrs nil (concat (url-file-extension w3-name t)
  328.                     ".hdr"))
  329.       (condition-case ()
  330.       (copy-file netscape-name w3-name t)
  331.     (error nil)))))
  332.  
  333. (if (not (fboundp 'abs))
  334.     (defun abs (arg)
  335.       "Return the absolute value of ARG."
  336.       (if (< 0 arg) (- arg) arg)))
  337.  
  338. (defvar w3-directory "/usr/local/lib/emacs/site-lisp/w3")
  339.  
  340. (defun w3-install-latest ()
  341.   "Install the latest version of the W3 world wide web browser."
  342.   (interactive)
  343.   (let* (
  344.      (sorted-tar-files
  345.       ;; This sort fails when the length of the version number changes!
  346.       ;; But Bill P. hereby promises not to let that happen. :)
  347.       (sort (delq nil
  348.               (mapcar (function
  349.                    (lambda (filename)
  350.                  (let ((len (length filename)))
  351.                    (and (> len 7)
  352.                     (string=
  353.                      ".tar.gz"
  354.                      (substring filename
  355.                             (- len 7) len))
  356.                     filename))))
  357.                   (file-name-all-completions
  358.                    "w3-" "/anonymous@cs.indiana.edu:/pub/elisp/w3/")))
  359.         (function string<)))
  360.      (tar-file
  361.       (nth (1- (length sorted-tar-files)) sorted-tar-files))
  362.      (version-string (substring tar-file 3 (- (length tar-file) 7)))
  363.      (new-directory
  364.       (concat "w3-" version-string))
  365.      (default-directory
  366.        (concat "~/emacs/site-lisp")))
  367.     (if (file-exists-p (concat default-directory "/" new-directory))
  368.     (error "W3 version %s has already been installed." version-string))
  369.     ;; We don't use /tmp because it might be on a different filesystem, so it
  370.     ;; couldn't just be renamed.
  371.     (make-directory "w3-tmp")
  372.     (copy-file (concat "/anonymous@cs.indiana.edu:/pub/elisp/w3/" tar-file)
  373.            "w3-tmp")
  374.     ;; This doesn't work right without "default-directory" in the cd.
  375.     (shell-command (concat "cd " default-directory "/w3-tmp; "
  376.                "gunzip -qc " tar-file " | tar xvf -"))
  377.     (shell-command (concat "cd " default-directory "/w3-tmp/w3; cp w3.info* /usr/local/info"))
  378.     (rename-file "w3-tmp/w3" new-directory)
  379.     (delete-file (concat "w3-tmp/" tar-file))
  380.     (delete-directory "w3-tmp")
  381.     (delete-file "w3")            ; get rid of the old link
  382.     ;; This doesn't work right without the cd.
  383.     (shell-command (concat "cd " default-directory "; ln -s " new-directory " w3" ))
  384.     (shell-command (concat "cd " default-directory "/w3; etags *.el"))))
  385.  
  386. (provide 'w3-beta)
  387.